home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d26 / cattest.arc / EVAL3.PAS < prev    next >
Pascal/Delphi Source File  |  1991-07-01  |  15KB  |  454 lines

  1. unit Eval3;
  2. interface
  3. uses Crt,Utility;
  4.  
  5. PROCEDURE Evaluate(VAR Formula: STRING; { Fomula to evaluate}
  6.                    VAR Value: Real;  { Result of formula }
  7.                    VAR ErrPos: Integer;{ Position of error }
  8.                    VAR ErrMsg: STRING); { Message of error }
  9.  
  10. implementation
  11.  
  12. PROCEDURE Evaluate(VAR Formula: STRING; { Fomula to evaluate}
  13.                    VAR Value: Real;  { Result of formula }
  14.                    VAR ErrPos: Integer;{ Position of error }
  15.                    VAR ErrMsg: STRING); { Message of error }
  16. (* COMMENTS
  17. 1) modified IV/27/1990-does bracket checking internally
  18.                       -does not allow alphabetic material in equations
  19.                       -reports error kind as well as position
  20.                           1 = brackets not balanced
  21.                           2 = alphabetic in formula
  22.              V/29/1990-uses error message text.
  23. *)
  24.  
  25. CONST
  26.   Numbers: SET OF Char = ['0'..'9','.'];
  27.   EofLine  = ^M;
  28.  
  29. VAR
  30.   Position: Integer;    { Current position in formula                     }
  31.   Ch: Char;        { Current character being scanned                 }
  32.   k,
  33.   brkt_counter : Integer;
  34.   Formula_save : string;
  35.  
  36. { Procedure NextCh returns the next character in the formula         }
  37. { The variable Pos contains the position ann Ch the character        }
  38.  
  39. { eval.pas }
  40.  
  41.   { Evaluate an infix expression typed on the command line.  Give no arguments
  42.      to get the help message.  Bruce K. Hillyer.
  43.  
  44.    This program is written for Microsoft pascal to use the REAL type,
  45.      which seems to avoid answers like 0.999999999999999 when the correct
  46.      answer is 1.
  47.  
  48.    Note that some versions of Microsoft pascal incorrectly decide that your pc
  49.      has an 8087 or 80287 math coprocessor when in fact it doesn't.  To check
  50.      this, try a simple multiplication.  If  eval 2*3   says 2, rather than 6,
  51.      set the enviornment variable   set NO87=X   in your autoexec.bat file.
  52.  
  53.    This code is derived in part from the spreadsheet that comes with turbo
  54.      pascal, which contains the following message:
  55.  
  56.         MICROCALC DEMONSTRATION PROGRAM  Version 1.00A
  57.  
  58.        This program is hereby donated to the public domain
  59.        for non-commercial use only.  Dot commands are  for
  60.        the program lister: LISTT.PAS  (available with  our
  61.        TURBO TUTOR):    .PA, .CP20, etc...
  62.   }
  63.  
  64. TYPE
  65.   exprStr   = STRING;
  66.  
  67. VAR
  68.   retnVl : REAL;
  69.   errLoc : INTEGER;
  70.   i : INTEGER;
  71.  
  72.  
  73. { functions for REAL }
  74. (*
  75. FUNCTION Andrqq(  a : REAL) : REAL;    { round }
  76.  
  77. FUNCTION Aidrqq(  a : REAL) : REAL;    { trunc }
  78.  
  79. FUNCTION Srdrqq(  a : REAL) : REAL;    { sqrt }
  80.  
  81. FUNCTION Sndrqq(  a : REAL) : REAL;    { sin }
  82.  
  83. FUNCTION Cndrqq(  a : REAL) : REAL;    { cos }
  84.  
  85. FUNCTION Tndrqq(  a : REAL) : REAL;    { tan }
  86.  
  87. FUNCTION Asdrqq(  a : REAL) : REAL;    { arcsin }
  88.  
  89. FUNCTION Acdrqq(  a : REAL) : REAL;    { arccos }
  90.  
  91. FUNCTION Atdrqq(  a : REAL) : REAL;    { arctan }
  92.  
  93. FUNCTION Shdrqq(  a : REAL) : REAL;    { sinh }
  94.  
  95. FUNCTION Chdrqq(  a : REAL) : REAL;    { cosh }
  96.  
  97. FUNCTION Thdrqq(  a : REAL) : REAL;    { tanh }
  98.  
  99. FUNCTION Lndrqq(  a : REAL) : REAL;    { ln }
  100.  
  101. FUNCTION Lddrqq(  a : REAL) : REAL;    { log }
  102.  
  103. FUNCTION Exdrqq(  a : REAL) : REAL;    { exp }
  104.  
  105. FUNCTION Pidrqq(  a : REAL;   b : INTEGER) : REAL;  {power}
  106.  
  107. FUNCTION Prdrqq(  a, b : REAL) : REAL;   { power }
  108.  
  109. FUNCTION Mddrqq(  a, b : REAL) : REAL;   { mod }
  110.  
  111. FUNCTION Mndrqq(  a, b : REAL) : REAL;   { min }
  112.  
  113. FUNCTION Mxdrqq(  a, b : REAL) : REAL;   { max }
  114.  
  115. PROCEDURE Endxqq;    { halt }
  116. *)
  117.  
  118. PROCEDURE strToNum(formula : exprStr; start, len : INTEGER;
  119.                    VAR retVal : REAL; VAR errPos : INTEGER);
  120.  
  121.   VAR
  122.     tempStr : STRING;
  123.     i : INTEGER;
  124.   BEGIN
  125.     tempStr := COPY(formula,start,len);
  126.     WHILE (Length(tempStr) > 0 ) AND (tempStr[1] = ' ') DO
  127.       Delete(tempStr,1,1);
  128.     IF tempStr[1] = '.'
  129.       THEN Insert('0',tempStr,1);
  130.     IF tempStr[1] = '+'
  131.       THEN Delete(tempStr,1,1);
  132.     VAL(tempStr,retVal,errPos);
  133.  
  134.   END; { strToNum }
  135.  
  136.  
  137.  
  138. PROCEDURE printNum(num : REAL);
  139.   VAR
  140.     pointLoc : INTEGER;
  141.     tempStr : STRING;
  142.     ErrPos : INTEGER;
  143.   BEGIN
  144.     IF (num = Round(num)) AND (num <= 1.0e17) THEN { integer }
  145.       BEGIN
  146.         STR(int(num):1:0,tempStr);
  147.         Writeln(tempStr)
  148.       END
  149.     ELSE IF Abs(num) > 1.0e6
  150.            THEN Writeln(num:24)  { big float }
  151.            ELSE BEGIN
  152.                   Str(Abs(num):1:16,tempStr);
  153.            { the position of the decimal point is one more than the number
  154.                of digits in the absolute value of the integer part }
  155.                   pointLoc := Pos('.',tempStr);
  156.                   IF pointLoc = 0
  157.                     THEN Writeln(output,num:1:0)
  158.                     ELSE BEGIN
  159.                       STR(num:1:(16-pointLoc),tempStr);
  160. (*                      WHILE (Length(tempStr) > pointLoc) AND
  161.                                  (tempStr[Length(tempStr)] = '0') DO{};*)
  162.                        Writeln(output,tempStr)
  163.                       END
  164.              END
  165.   END; { printNum }
  166.  
  167.  
  168.  
  169. (*
  170. PROCEDURE evaluate(formula : exprStr; VAR exprVl: REAL; VAR errPos: INTEGER);
  171.   { evaluate the formula }*)
  172.  
  173. VAR
  174.   pos : INTEGER;    { current position in formula      }
  175.  
  176.   function Min(x,y:real):real;
  177.   begin
  178.     if x>y then Min := y else Min := x;
  179.   end;
  180.   function Max(x,y:real):real;
  181.   begin
  182.     if x>y then Max := x else Max := y;
  183.   end;
  184.  
  185.   PROCEDURE nextCh;
  186.     { get the next character into ch, set pos, <cr> indicates eos }
  187.     BEGIN
  188.       REPEAT
  189.         pos := pos + 1;
  190.                IF pos <= Length(formula)
  191.                  THEN ch := formula[pos]
  192.                                ELSE ch := Chr(0)
  193.       UNTIL ch <> ' '
  194.     END; { nextCh }
  195.  
  196.  
  197.   FUNCTION expression : REAL;
  198.  
  199.     VAR 
  200.       e : REAL;
  201.  
  202.     FUNCTION simpleExpression : REAL;
  203.  
  204.       VAR
  205.         s : REAL;
  206.  
  207.       FUNCTION term : REAL;
  208.  
  209.         VAR
  210.           t,t2 : REAL;
  211.  
  212.         FUNCTION signedFactor : REAL;
  213.  
  214.           FUNCTION factor : REAL;
  215.  
  216.             TYPE
  217.               builtin = (fabs, fround, ftrunc, fsqrt, fsqr, fsin, fcos, ftan,
  218.                          farcsin, farccos, farctan, fsinh, fcosh, ftanh,
  219.                          fln, flog, flog2, fexp, ffact);
  220.               builtinList = ARRAY[builtin] OF STRING;
  221.  
  222.               CONST 
  223.                 builtinNames : (*builtinList*)
  224.                                array[builtin] of string =
  225.                                ('abs', 'round', 'trunc', 'sqrt', 'sqr', 'sin', 'cos','tan'
  226.                                 ,
  227.                                 'arcsin', 'arccos', 'arctan', 'sinh', 'cosh', 'tanh',
  228.                                 'ln', 'log', 'log2', 'exp', 'fact');
  229.  
  230.             VAR 
  231.               e,l : INTEGER;       { intermediate variables }
  232.               found : BOOLEAN;
  233.               f : REAL;
  234.               fn : builtin;
  235.               start : INTEGER;
  236.  
  237.          FUNCTION thisFn(inp : exprStr; pos : INTEGER; fn : builtin)
  238.                        : BOOLEAN;
  239.            { see if the input at location pos contains the fn name }
  240.  
  241.            VAR
  242.              i : INTEGER;
  243.            BEGIN
  244.              thisFn := TRUE;
  245.              FOR i:=1 TO length(builtinNames[fn]) DO
  246.                IF inp[i+pos-1] <> builtinNames[fn,i]
  247.                  THEN thisFn := FALSE
  248.            END; { thisFn }
  249.  
  250.  
  251.               FUNCTION factorial(arg : REAL): REAL;
  252.                 BEGIN
  253.                   arg := (*Andrqq*)Round(arg);  { round it to avoid strangeness }
  254.                   IF arg > 170
  255.                     THEN
  256.                       BEGIN
  257.                         Writeln(output,'factorial: Too large argument');
  258.                         exit;
  259.                       END;
  260.                   IF arg < 0
  261.                     THEN
  262.                       BEGIN
  263.                         Writeln(output,'factorial: Negative argument');
  264.                         exit;
  265.                       END;
  266.                   IF arg > 0
  267.                     THEN factorial := arg * factorial(arg-1)
  268.                     ELSE factorial := 1
  269.                 END; { factorial }
  270.  
  271.  
  272.           FUNCTION log2(  a : REAL) : REAL;
  273.             BEGIN
  274.               log2 := Ln(a) / Ln(2.0)
  275.          END; { log2 }
  276.  
  277.  
  278.  
  279.           BEGIN { factor }
  280.             IF ((ch >= '0') AND (ch <= '9')) OR (ch = '.')
  281.               THEN
  282.                 BEGIN
  283.                   start := pos;
  284.                   REPEAT
  285.                     nextCh
  286.                   UNTIL (ch < '0') OR (ch > '9');
  287.                   IF ch = '.'
  288.                     THEN
  289.                       REPEAT
  290.                         nextCh
  291.                       UNTIL (ch < '0') OR (ch > '9');
  292.                   strToNum(formula,start,pos-start,f,errPos)
  293.                 END
  294.               ELSE IF ch='('
  295.                      THEN
  296.                        BEGIN
  297.                          nextCh;
  298.                          f := expression;
  299.                          IF ch=')'
  300.                            THEN nextCh
  301.                            ELSE errPos := pos
  302.                        END
  303.                      ELSE
  304.                        BEGIN { parse builtin function }
  305.                          found := false;
  306. (*                         FOR fn := Lower(fn) TO Upper(fn) DO*)
  307.                          for fn := fabs to ffact do
  308.                            IF NOT found
  309.                              THEN
  310.                                BEGIN { check this function name }
  311.                                  l := Length(builtinNames[fn]);
  312.                                  IF thisFn(formula,pos,fn)
  313.                                    THEN
  314.                                      BEGIN { call builtin }
  315.                                        pos := pos + l - 1;
  316.                                        nextCh;
  317.                                        f := factor;
  318.                                        CASE fn OF
  319.                                          fabs:     f := Abs(f);
  320.                                          fround:   f := round(f);
  321.                                          ftrunc:   f := trunc(f);
  322.                                          fsqrt:    f := Sqrt(f);
  323.                                          fsqr:     f := f*f;
  324.                                          fsin:     f := Sin(f);
  325.                                          fcos:     f := Cos(f);
  326.                                          ftan:     f := Sin(f)/Cos(f);
  327.                                       (*   farcsin:  f := Asdrqq(f);
  328.                                          farccos:  f := Acdrqq(f);*)
  329.                                          farctan:  f := ArcTan(f);
  330.                                          (*fsinh :   f := Shdrqq(f);
  331.                                          fcosh :   f := Chdrqq(f);
  332.                                          ftanh :   f := Thdrqq(f);*)
  333.                                          fln :     f := Ln(f);
  334.                                          flog:     f := Ln(f)/2.303;
  335.                                          flog2:    f := log2(f);
  336.                                          fexp:     f := Exp(f);
  337.                                          ffact:    f := factorial(f);
  338.                                        END; { CASE }
  339.                                        found := TRUE;
  340.                                      END; { call builtin }
  341.                                END; { check this function name }
  342.                          IF NOT found
  343.                            THEN errPos := pos;
  344.                        END; { parse builtin function }
  345.               factor := f
  346.           END; { factor }
  347.  
  348.         BEGIN { signedFactor }
  349.           WHILE ch = ' ' DO
  350.             nextCh;
  351.           IF ch = '-'
  352.             THEN BEGIN
  353.                    nextCh;
  354.                     signedFactor := -factor
  355.                  END
  356.             ELSE IF ch = '+'
  357.                    THEN BEGIN
  358.                           nextCh;
  359.                           signedFactor := factor
  360.                      END
  361.                    ELSE signedFactor := factor
  362.         END; { signedFactor }
  363.  
  364.       BEGIN { term }
  365.         t := signedFactor;
  366.         WHILE (ch = '^') AND (errPos = 0) DO  {power}
  367.           BEGIN
  368.             nextCh;
  369.             t2 := signedFactor;
  370.             t := exp(t2*ln(t));
  371.           END;
  372.         term := t
  373.       END; { term }
  374.  
  375.     BEGIN { simpleExpression }
  376.       s := term;
  377.       WHILE ((ch = '*') OR (ch = '/') OR (ch = '\') OR (ch = 'm'))
  378.             AND (errPos = 0) DO
  379.         IF ch = '/'
  380.           THEN BEGIN
  381.                  nextCh;
  382.                      s := s / term
  383.                END
  384.           ELSE IF ch = '*'
  385.                  THEN BEGIN
  386.                         nextCh;
  387.                         s := s * term
  388.                     END
  389. (*                 ELSE IF ch = '\'
  390.                         THEN BEGIN
  391.                                nextCh;
  392.                                s := s mod (term)
  393.                               END *)
  394.                         ELSE IF ch = 'm'
  395.                                THEN
  396.                                  BEGIN
  397.                                    nextCh;
  398.                                    IF ch = 'i'
  399.                                      THEN BEGIN
  400.                                             nextCh;
  401.                                             IF ch = 'n'
  402.                                               THEN BEGIN
  403.                                                      nextCh;
  404.                                                      s := Min(s,(term))
  405.                                                 END
  406.                                               ELSE errPos := pos
  407.                                        END
  408.                                      ELSE IF ch = 'a'
  409.                                             THEN BEGIN
  410.                                                    nextCh;
  411.                                                    IF ch = 'x'
  412.                                                      THEN BEGIN
  413.                                                             nextCh;
  414.                                                             s := Max(s,(term))
  415.                                                        END
  416.                                                      ELSE errPos := pos
  417.                                               END
  418.                                             ELSE errPos := pos
  419.                                  END;
  420.       simpleExpression := s
  421.     END; { simpleExpression }
  422.  
  423.   BEGIN { expression }
  424.     e := simpleExpression;
  425.     WHILE ((ch = '+') OR (ch = '-')) AND (errPos = 0) DO
  426.       IF ch = '-'
  427.         THEN BEGIN
  428.                nextCh;
  429.                    e := e - simpleExpression
  430.                 END
  431.                   ELSE BEGIN
  432.                          nextCh;
  433.                          e := e + simpleExpression
  434.                     END;
  435.     expression := e
  436.   END; { expression }
  437.  
  438.  
  439. BEGIN { evaluate }
  440.  
  441.   pos := 0;
  442.   ErrPos := 0;
  443.   nextCh;
  444.   Formula_save := Formula;
  445.   value := expression;
  446.   if pos < Length(Formula) then
  447.   begin
  448.     ErrPos := pos;
  449.     ErrMsg := 'BAD PARSE,->'+Formula_save;
  450.   end
  451.     else ErrMsg := OK_Message;
  452. END; { evaluate }
  453. END.
  454.